home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / magazi~1 / 371 / picpuzzl.pas < prev    next >
Pascal/Delphi Source File  |  1989-03-10  |  32KB  |  882 lines
  1. {******************************************************************}
  2. {*  Picture Puzzle is a game that takes a picture of format .NEO, *}
  3. {*  .PI1, .PI2, or .PI3 and let's you break that picture up into  *}
  4. {*  several pieces.  Those pieces are then shuffled and you must  *}
  5. {*  rearrange those pieces into the picture again.  This program  *}
  6. {*  was written so the author could create routines to read in    *}
  7. {*  picture files.  It was also written as an introduction to the *}
  8. {*  bit blit operations available on the Atari ST.                *}
  9. {*                                                                *}
  10. {*             COPYRIGHT 1988 BY ST-LOG MAGAZINE                  *}
  11. {******************************************************************}
  12.  
  13. PROGRAM Picture_Puzzle ;
  14.  
  15.   CONST
  16.     {$I GEMCONST.PAS}
  17.     right_arrow = $4D00 ;
  18.     left_arrow = $4B00 ;
  19.     up_arrow = $4800 ;
  20.     down_arrow = $5000 ;
  21.     PF1 = $3B00 ;
  22.     Low_Resolution = 1 ;
  23.     Medium_Resolution = 2 ;
  24.     High_Resolution = 3 ;
  25.  
  26.   TYPE
  27.     {$I gemtype.pas}
  28.     palet = ARRAY [0..15] OF Integer ;
  29.     PI_Record = Record
  30.       res : Integer ;
  31.       palette : palet ;
  32.       image : Array [1..16000] OF Integer ;
  33.     END ;
  34.     NEO_Record = Record
  35.       res : Long_Integer ;
  36.       palette : palet ;
  37.       miscellany : Array [0..45] OF Integer ;
  38.       image : Array [1..16000] OF Integer ;
  39.     END ;
  40.     scrn_memory     = ARRAY [1..16000] OF Integer;
  41.     mfdb_fields     =
  42.        (addr1,addr2,wid_pix,ht_pix,wid_wds,flag,num_planes,r1,r2,r3);
  43.     mfdb            = ARRAY [mfdb_fields] OF Integer;
  44.  
  45.   VAR
  46.     screen,backup,image_area : MFDB;
  47.     screen_buffer : scrn_memory;
  48.  
  49.     PI_file : FILE OF PI_Record ;
  50.     PI_image: PI_Record ;
  51.  
  52.     NEO_file : FILE OF NEO_Record ;
  53.     NEO_image: NEO_Record ;
  54.  
  55.     palette, save_palette : palet ;  { working palette }
  56.  
  57.     Xmax, Ymax, Wmax, Hmax, resolution, dummy, key, event,
  58.     palette_max, vertical, horizontal, rect_width, rect_height,
  59.     left_margin, top_margin, chosen: Integer ;
  60.  
  61.     msg: Message_Buffer ;
  62.     default_path: Path_Name ;
  63.     block_position: Array [0..21, 0..21] OF Integer ;
  64.     puzzle_solved: Boolean ;
  65.     res_string : Array [0..3] OF Str255 ;
  66.     alert_str: Str255 ;
  67.  
  68.   {$I gemsubs.pas}
  69.  
  70. {******************************************************************}
  71. {*  These two routines are linked with the program.  They were    *}
  72. {*  taken from O.S.S.'s bulletin board and allow me to use bit    *}
  73. {*  blit operations.                                              *}
  74. {******************************************************************}
  75.  
  76. PROCEDURE init_form(var form: MFDB ; var addr : scrn_memory ;
  77.                     resolution : Integer) ;
  78.   EXTERNAL ;
  79.  
  80. PROCEDURE copy_rect(var s,d : MFDB ;
  81.                   from_x, from_y, to_x, to_y, wid, ht: Integer) ;
  82.   EXTERNAL ;
  83.  
  84. {******************************************************************}
  85. {*  I call this routine in order to retrieve the current color    *}
  86. {*  register settings.  This is in order to return the original   *}
  87. {*  colors when exiting the program.                              *}
  88. {******************************************************************}
  89.  
  90. FUNCTION st_clr( register, color: integer): integer ;
  91.    Xbios( 7 );
  92.  
  93. {******************************************************************}
  94. {*  These are the random number routines taken from the O.S.S.    *}
  95. {*  bulletin board.  I call these routines to choose random rec-  *}
  96. {*  tangles when I shuffle up the picture.                        *}
  97. {******************************************************************}
  98.  
  99. Function XB_Rnd : Long_Integer;  { get xbios random 24-bit number }
  100.    Xbios( 17 );
  101.  
  102. Function Rnd : Real;
  103.  
  104.    Begin
  105.       Rnd := XB_Rnd / 16777216.0;
  106.    End;
  107.  
  108. Function Random( Low, Hi : Integer ) : Integer;
  109.  
  110.    Begin
  111.       Random := Low + Trunc( Rnd * ( Hi - Low +1 ) );
  112.    End;
  113.  
  114. {******************************************************************}
  115. {*  This routine is used to determine the mouse x/y position.     *}
  116. {*  I previously used the Get_Event function but this was only    *}
  117. {*  partially effective as it did not recognize a mouse event at  *}
  118. {*  the top of the screen in the menu area.                       *}
  119. {******************************************************************}
  120.  
  121. PROCEDURE sample_mouse(VAR status, x_posit, y_posit: integer) ;
  122.  
  123.     TYPE
  124.       Ctrl_Parms      = ARRAY [ 0..11 ] OF integer ;
  125.       Int_In_Parms    = ARRAY [ 0..15 ] OF integer ;
  126.       Int_Out_Parms   = ARRAY [ 0..45 ] OF integer ;
  127.       Pts_In_Parms    = ARRAY [ 0..11 ] OF integer ;
  128.       Pts_Out_Parms   = ARRAY [ 0..11 ] OF integer ;
  129.  
  130.     VAR
  131.       control : Ctrl_Parms ;
  132.       int_in  : Int_In_Parms ;
  133.       int_out : Int_Out_Parms ;
  134.       pts_in  : Pts_In_Parms ;
  135.       pts_out : Pts_Out_Parms ;
  136.  
  137.     PROCEDURE VDI_Call( cmd, sub_cmd : integer ; nints, npts : integer ;
  138.                 VAR ctrl : Ctrl_Parms ;
  139.                 VAR int_in : Int_In_Parms ; VAR int_out : Int_Out_Parms ;
  140.                 VAR pts_in : Pts_In_Parms ; VAR pts_out : Pts_Out_Parms ;
  141.                 translate : boolean ) ;
  142.       EXTERNAL ;
  143.  
  144. begin
  145.    VDI_Call(124,0,0,0,control,int_in,int_out,pts_in,pts_out,false);
  146.    status := int_out[0] ;
  147.    x_posit := pts_out[0] ;
  148.    y_posit := pts_out[1] ;
  149. end;
  150.  
  151. {******************************************************************}
  152. {*  I call this routine to set the color palette to the colors    *}
  153. {*  read in from the picture files.                               *}
  154. {******************************************************************}
  155.  
  156. PROCEDURE Set_Palette(pal: palet) ;
  157.  
  158. VAR x: Integer ;
  159.  
  160.   BEGIN
  161.     FOR x := 0 TO palette_max DO
  162.       BEGIN
  163.         IF x = palette_max THEN
  164.           palette[1] := pal[x]
  165.         ELSE
  166.           CASE x OF
  167.             0,4,12 : palette[x] := pal[x] ;
  168.             1,2,7,8,9,10 : palette[x+1] := pal[x] ;
  169.             3,11 : palette[x+3] := pal[x] ;
  170.             5,13 : palette[x+2] := pal[x] ;
  171.             6,14 : palette[x-1] := pal[x] ;
  172.           END ;
  173.       END ;
  174.     {set colors here}
  175.     FOR x := 0 TO 15 DO
  176.       Set_Color( x, Shr(Shl(palette[x],5),13)*124+62,
  177.                     Shr(Shl(palette[x],9),13)*124+62,
  178.                     Shr(Shl(palette[x],13),13)*124+62) ;
  179.   END ;
  180.  
  181. {******************************************************************}
  182. {*  This procedure is called to erase the screen.                 *}
  183. {******************************************************************}
  184.  
  185. PROCEDURE erase_screen ;
  186.  
  187.   BEGIN
  188.     hide_mouse ;
  189.     clear_screen ;
  190.     show_mouse ;
  191.   END ;
  192.  
  193. {******************************************************************}
  194. {*  This function returns the resolution in which the program is  *}
  195. {*  currently being executed.                                     *}
  196. {******************************************************************}
  197.  
  198. FUNCTION Get_Res: Integer ;
  199.  
  200.   BEGIN
  201.     Work_Rect( 0, Xmax, Ymax, Wmax, Hmax ) ;
  202.     IF Wmax=320 THEN
  203.         Get_Res := Low_Resolution
  204.     ELSE
  205.       IF Hmax>200 THEN
  206.         Get_Res := High_Resolution
  207.       ELSE
  208.         Get_Res := Medium_Resolution ;
  209.   END ;
  210.  
  211. {******************************************************************}
  212. {*  This is the main loop.  Within it the picture file is chosen, *}
  213. {*  and then manipulated by the user.                             *}
  214. {******************************************************************}
  215.  
  216. PROCEDURE Main_Loop ;
  217.  
  218. VAR file_name: Path_Name ;
  219.     file_to_input, valid_ext: Boolean ;
  220.     x, result, pi1_spot, pi2_spot, pi3_spot, neo_spot: Integer ;
  221.  
  222. {******************************************************************}
  223. {*  This routine will always display the picture image in it's    *}
  224. {*  completed form.                                               *}
  225. {******************************************************************}
  226.  
  227. PROCEDURE Display_Picture ;
  228.  
  229. VAR x: Integer ;
  230.  
  231.   BEGIN
  232.     hide_mouse ;
  233.     copy_rect(image_area,screen,0,0,0,0,Wmax,Hmax) ;
  234.     show_mouse ;
  235.   END ;
  236.  
  237. {******************************************************************}
  238. {*  This routine allows the user to break up the picture in any   *}
  239. {*  combination of rectangles.                                    *}
  240. {******************************************************************}
  241.  
  242. PROCEDURE get_squares ;
  243.  
  244. VAR x, y, vert_lines, horz_lines,
  245.     offset_1, offset_2, work_1, work_2: Integer ;
  246.  
  247. {******************************************************************}
  248. {*  This routine is called if the user hits the PF1 key while     *}
  249. {*  breaking up the picture into rectangles.  It allows the user  *}
  250. {*  to select the color of the lines which seperate each rectan-  *}
  251. {*  gle.  Only those colors in the current palette may be chosen. *}
  252. {******************************************************************}
  253.  
  254. PROCEDURE change_line_color ;
  255.  
  256. VAR color_dialog: Dialog_Ptr ;
  257.     pattern, x, ok_button: Integer ;
  258.     color_item: palet ;
  259.  
  260.   BEGIN
  261.     color_dialog := New_Dialog( 18, 0, 0, 27, 12 ) ;
  262.     ok_button := Add_DItem(color_dialog, G_Button, Selectable|Exit_Btn,
  263.                              11, 8, 5, 2, 1, 0) ;
  264.     FOR x := 0 TO 15 DO
  265.       BEGIN
  266.         IF x>palette_max THEN
  267.           BEGIN
  268.             pattern := 1 ;
  269.             color_item[x] := Add_DItem(color_dialog, G_Box, None,
  270.                              (x*3)+2-(8*(x DIV 8)*3), (x DIV 8)*3+2,
  271.                              2, 2, -1, x|(pattern*16)|4096) ;
  272.           END
  273.         ELSE
  274.           BEGIN
  275.             pattern := 7 ;
  276.             color_item[x] := Add_DItem(color_dialog, G_Box,
  277.                          Selectable|Exit_Btn, (x*3)+2-(8*(x DIV 8)*3),
  278.                          (x DIV 8)*3+2, 2, 2, -1,
  279.                          x|(pattern*16)|4096|128) ;
  280.           END ;
  281.       END ;
  282.     FOR x := 0 TO 15 DO
  283.       IF x = chosen THEN
  284.         obj_setstate(color_dialog, color_item[x], checked, false) ;
  285.     set_dtext(color_dialog, ok_button, 'OK', system_font, TE_Center) ;
  286.     center_dialog(color_dialog) ;
  287.     dummy := do_dialog(color_dialog, 0) ;
  288.     While dummy<>ok_button DO
  289.       BEGIN
  290.         FOR x := 0 TO 15 DO
  291.           IF dummy = color_item[x] THEN
  292.             BEGIN
  293.               chosen := x ;
  294.               IF Obj_State(color_dialog, color_item[x])&checked=0 THEN
  295.                 BEGIN
  296.                   obj_setstate(color_dialog, color_item[x], normal, true) ;
  297.                   obj_setstate(color_dialog, color_item[x], checked, true) ;
  298.                 END
  299.               ELSE
  300.                 BEGIN
  301.                   obj_setstate(color_dialog, color_item[x], checked, true) ;
  302.                   obj_setstate(color_dialog, color_item[x], normal, true) ;
  303.                 END ;
  304.             END
  305.           ELSE
  306.             IF Obj_State(color_dialog, color_item[x])&checked<>0 THEN
  307.               BEGIN
  308.                 obj_setstate(color_dialog, color_item[x], selected, true) ;
  309.                 obj_setstate(color_dialog, color_item[x], checked, true) ;
  310.                 obj_setstate(color_dialog, color_item[x], normal, true) ;
  311.               END ;
  312.         dummy := redo_dialog(color_dialog, 0) ;
  313.       END ;
  314.     Line_Color(chosen) ;
  315.     end_dialog(color_dialog) ;
  316.     delete_dialog(color_dialog) ;
  317.   END ;
  318.  
  319. {******************************************************************}
  320. {*  This is the beginning of routine get_squares.  The user uses  *}
  321. {*  the arrow keys and the PF1 key to break up the picture.  The  *}
  322. {*  user may hit the escape key at any time whereupon the program *}
  323. {*  will return to the file selection menu.                       *}
  324. {******************************************************************}
  325.  
  326.   BEGIN
  327.     display_picture ;
  328.     horizontal := 1 ;
  329.     vertical := 1 ;
  330.     line_style(1) ;
  331.     draw_mode(1) ;
  332.     event := Get_Event( E_Keyboard, 0, 0, 0, 0, False,
  333.                         0, 0, 0, 0, False, 0, 0, 0, 0, msg,
  334.                         key, dummy, dummy, dummy, dummy, dummy ) ;
  335.     WHILE (key=right_arrow) OR (key=left_arrow) OR
  336.           (key=up_arrow)    OR (key=down_arrow) OR (key=PF1) DO
  337.       BEGIN
  338.         CASE key OF
  339.           right_arrow: IF horizontal<22 THEN
  340.                          horizontal := horizontal + 1 ;
  341.           left_arrow:  IF horizontal > 1 THEN
  342.                          horizontal := horizontal - 1 ;
  343.           up_arrow:    IF vertical<22 THEN
  344.                          vertical := vertical + 1 ;
  345.           down_arrow:  IF vertical > 1 THEN
  346.                          vertical := vertical - 1 ;
  347.         END ;
  348.  
  349.         IF key=PF1 THEN
  350.           change_line_color ;
  351.  
  352.         display_picture ;
  353.  
  354.         vert_lines := 0 ;
  355.         horz_lines := 0 ;
  356.         left_margin := 0 ;
  357.         top_margin := 0 ;
  358.         rect_width := Wmax ;
  359.         rect_height := Hmax ;
  360.  
  361.         hide_mouse ;
  362.         IF vertical>1 THEN
  363.           BEGIN
  364.             REPEAT
  365.               vert_lines := vertical-1+2 ;
  366.               rect_width := (Wmax-vert_lines) DIV vertical ;
  367.               left_margin := (((Wmax-vert_lines) MOD vertical) DIV 2) + 1 ;
  368.               IF rect_width=0 THEN
  369.                 vertical := vertical-1 ;
  370.             UNTIL rect_width>0 ;
  371.           END ;
  372.  
  373.         IF horizontal>1 THEN
  374.           BEGIN
  375.             REPEAT
  376.               horz_lines := horizontal-1+2 ;
  377.               rect_height := (Hmax-horz_lines) DIV horizontal ;
  378.               top_margin := (((Hmax-horz_lines) MOD horizontal) DIV 2) + 1 ;
  379.               IF rect_height=0 THEN
  380.                 horizontal := horizontal-1 ;
  381.             UNTIL rect_height>0 ;
  382.           END ;
  383.  
  384.           IF left_margin>0 THEN
  385.             offset_1 := left_margin-1
  386.           ELSE
  387.             offset_1 := left_margin ;
  388.  
  389.           IF top_margin>0 THEN
  390.             offset_2 := top_margin-1
  391.           ELSE
  392.             offset_2 := top_margin ;
  393.  
  394.           IF vertical>1 THEN
  395.             BEGIN
  396.               work_2 := (horizontal*rect_height)+horz_lines+offset_2-1 ;
  397.               FOR x := 1 TO vert_lines DO
  398.                 BEGIN
  399.                   work_1 := (x-1)*(rect_width+1)+offset_1 ;
  400.                   Line(work_1, offset_2 , work_1, work_2 ) ;
  401.                 END ;
  402.             END ;
  403.  
  404.           IF horizontal>1 THEN
  405.             BEGIN
  406.               work_2 := (vertical*rect_width)+vert_lines+offset_1-1 ;
  407.               FOR x := 1 TO horz_lines DO
  408.                 BEGIN
  409.                   work_1 := (x-1)*(rect_height+1)+offset_2 ;
  410.                   Line(offset_1, work_1, work_2, work_1 ) ;
  411.                 END ;
  412.             END ;
  413.  
  414.         show_mouse ;
  415.  
  416.         event := Get_Event( E_Keyboard, 0, 0, 0, 0, False,
  417.                             0, 0, 0, 0, False, 0, 0, 0, 0, msg,
  418.                             key, dummy, dummy, dummy, dummy, dummy ) ;
  419.       END ;
  420.     FOR x := 0 TO horizontal-1 DO
  421.       FOR y := 0 TO vertical-1 DO
  422.         block_position[x,y] := x*vertical+y ;
  423.   END ;
  424.  
  425. {******************************************************************}
  426. {*  This routine is called after the user has broken up the pic-  *}
  427. {*  ture into rectangles.  This routine randomly shuffles up      *}
  428. {*  those rectangles.                                             *}
  429. {******************************************************************}
  430.  
  431. PROCEDURE shuffle_picture ;
  432.  
  433. VAR x, x1, x2, y1, y2, hold: Integer ;
  434.  
  435.   BEGIN
  436.     hide_mouse ;
  437.     FOR x := 1 TO horizontal*vertical*2 DO
  438.       BEGIN
  439.         x1 := Random(0,horizontal-1) ;
  440.         x2 := Random(0,horizontal-1) ;
  441.         y1 := Random(0,vertical-1) ;
  442.         y2 := Random(0,vertical-1) ;
  443.  
  444.         hold := block_position[x1,y1] ;
  445.         block_position[x1,y1] := block_position[x2,y2] ;
  446.         block_position[x2,y2] := hold ;
  447.  
  448.         copy_rect(backup,screen,rect_width*y1+y1+left_margin,
  449.                                 rect_height*x1+x1+top_margin,
  450.                                 rect_width*y2+y2+left_margin,
  451.                                 rect_height*x2+x2+top_margin,
  452.                                 rect_width,rect_height) ;
  453.         copy_rect(backup,screen,rect_width*y2+y2+left_margin,
  454.                                 rect_height*x2+x2+top_margin,
  455.                                 rect_width*y1+y1+left_margin,
  456.                                 rect_height*x1+x1+top_margin,
  457.                                 rect_width,rect_height) ;
  458.         copy_rect(screen,backup,0,0,0,0,Wmax,Hmax) ;
  459.       END ;
  460.     show_mouse ;
  461.   END ;
  462.  
  463. {******************************************************************}
  464. {*  This routine is called after the rectangles are shuffled.     *}
  465. {*  The user must now rearrange the puzzle by clicking the left   *}
  466. {*  button on any two (2) rectangles which will interchange.  If  *}
  467. {*  the user pushes the right mouse button and holds it down the  *}
  468. {*  picture in it's original stage will be displayed.             *}
  469. {******************************************************************}
  470.  
  471. PROCEDURE exchange_squares ;
  472.  
  473. VAR mx1, my1, mx2, my2, x1, y1, x2, y2,
  474.     x, y, hold, left_button, right_button: Integer ;
  475.  
  476. {******************************************************************}
  477. {*  This routine checks to see if the right mouse button has been *}
  478. {*  depressed.  If it has it then displays the original picture   *}
  479. {*  until the mouse button is released.                           *}
  480. {******************************************************************}
  481.  
  482. PROCEDURE check_right ;
  483.  
  484.   BEGIN
  485.     right_button := Get_Event( E_Keyboard|E_Button|E_Timer, 2, 2, 1, 0,
  486.                                False, 0, 0, 0, 0, False, 0, 0, 0, 0, msg,
  487.                                key, dummy, dummy, dummy, dummy, dummy ) ;
  488.     IF (right_button&E_Button)>0 THEN
  489.       BEGIN
  490.         hide_mouse ;
  491.         copy_rect(screen,backup,0,0,0,0,Wmax,Hmax) ;
  492.         show_mouse ;
  493.         display_picture ;
  494.         right_button := Get_Event( E_Button, 2, 0, 1, 0, False, 0, 0, 0, 0,
  495.                                    False, 0, 0, 0, 0, msg, key, dummy, dummy,
  496.                                    dummy, dummy, dummy ) ;
  497.         hide_mouse ;
  498.         copy_rect(backup,screen,0,0,0,0,Wmax,Hmax) ;
  499.         show_mouse ;
  500.       END ;
  501.   END ;
  502.  
  503. {******************************************************************}
  504. {*  This is the start of procedure exchange_squares.              *}
  505. {******************************************************************}
  506.  
  507.   BEGIN
  508.     puzzle_solved := True ;
  509.     FOR x := 0 TO horizontal-1 DO
  510.       FOR y := 0 TO vertical-1 DO
  511.         IF block_position[x,y]<>(x*vertical+y) THEN
  512.           puzzle_solved := False ;
  513.     WHILE (NOT puzzle_solved) AND (key<>$011B) DO
  514.       BEGIN
  515.         left_button := 0 ;
  516.         WHILE (left_button<>1) AND (key<>$011B) DO
  517.           BEGIN
  518.             sample_mouse(left_button, mx1, my1) ;
  519.             IF left_button=1 THEN
  520.               BEGIN
  521.                 y1 := (mx1-left_margin) DIV (rect_width+1) ;
  522.                 x1 := (my1-top_margin) DIV (rect_height+1) ;
  523.                 IF (y1>=vertical) OR (x1>=horizontal) OR (y1<0) OR (x1<0) THEN
  524.                   left_button := 0 ;
  525.               END
  526.             ELSE
  527.               check_right ;
  528.           END ;
  529.         IF key<>$011B THEN
  530.           BEGIN
  531.             {wait for left button up}
  532.             FOR x := 1 TO 30000 DO ;
  533.             left_button := 0 ;
  534.             WHILE (left_button<>1) AND (key<>$011B) DO
  535.               BEGIN
  536.                 sample_mouse(left_button, mx2, my2) ;
  537.                 IF left_button=1 THEN
  538.                   BEGIN
  539.                     y2 := (mx2-left_margin) DIV (rect_width+1) ;
  540.                     x2 := (my2-top_margin) DIV (rect_height+1) ;
  541.                     IF (y2>=vertical) OR (x2>=horizontal) OR
  542.                        (y2<0) OR (x2<0) THEN
  543.                       left_button := 0 ;
  544.                   END
  545.                 ELSE
  546.                   check_right ;
  547.               END ;
  548.             IF key<>$011B THEN
  549.               BEGIN
  550.                 {wait for left button up}
  551.                 FOR x := 1 TO 30000 DO ;
  552.                 hide_mouse ;
  553.                 y1 := (mx1-left_margin) DIV (rect_width+1) ;
  554.                 y2 := (mx2-left_margin) DIV (rect_width+1) ;
  555.                 x1 := (my1-top_margin) DIV (rect_height+1) ;
  556.                 x2 := (my2-top_margin) DIV (rect_height+1) ;
  557.                 copy_rect(backup,screen,rect_width*y1+y1+left_margin,
  558.                                         rect_height*x1+x1+top_margin,
  559.                                         rect_width*y2+y2+left_margin,
  560.                                         rect_height*x2+x2+top_margin,
  561.                                         rect_width,rect_height) ;
  562.                 copy_rect(backup,screen,rect_width*y2+y2+left_margin,
  563.                                         rect_height*x2+x2+top_margin,
  564.                                         rect_width*y1+y1+left_margin,
  565.                                         rect_height*x1+x1+top_margin,
  566.                                         rect_width,rect_height) ;
  567.                 copy_rect(screen,backup,0,0,0,0,Wmax,Hmax) ;
  568.                 show_mouse ;
  569.  
  570.                 hold := block_position[x1,y1] ;
  571.                 block_position[x1,y1] := block_position[x2,y2] ;
  572.                 block_position[x2,y2] := hold ;
  573.  
  574.                 puzzle_solved := True ;
  575.                 FOR x := 0 TO horizontal-1 DO
  576.                   FOR y := 0 TO vertical-1 DO
  577.                     IF block_position[x,y]<>(x*vertical+y) THEN
  578.                       puzzle_solved := False ;
  579.               END ;
  580.           END ;
  581.       END ;
  582.   END ;
  583.  
  584. {******************************************************************}
  585. {*  This function checks the resolution passed to it with the     *}
  586. {*  current resolution.  If they do not match an alert box is     *}
  587. {*  displayed saying so and a -99 is returned to indicate that    *}
  588. {*  the picture read in can not be displayed in the current res-  *}
  589. {*  olution.                                                      *}
  590. {******************************************************************}
  591.  
  592. FUNCTION Check_Res(image_res: integer): Integer ;
  593.  
  594.   BEGIN
  595.     check_res := 0 ;
  596.     IF (resolution-1)<>image_res THEN
  597.       BEGIN
  598.         alert_str := Concat('[3][',
  599.                             res_string[image_res],
  600.                             '|resolution to|load this file!]',
  601.                             '[Cancel]') ;
  602.         dummy := Do_Alert(alert_str,1) ;
  603.         check_res := -99 ;
  604.       END ;
  605.   END ;
  606.  
  607. {******************************************************************}
  608. {*  This function reads in a file with the extension of .NEO.     *}
  609. {******************************************************************}
  610.  
  611. FUNCTION Get_NEO: Integer ;
  612.  
  613. VAR result, x : Integer ;
  614.  
  615.   BEGIN
  616.     Reset( NEO_file, file_name ) ;
  617.     NEO_image := NEO_file^ ;
  618.     IO_Check(False) ;
  619.     Get( NEO_file ) ;
  620.     result := IO_Result ;
  621.     Close( NEO_file ) ;
  622.     IO_Check(True) ;
  623.     IF result=0 THEN
  624.       BEGIN
  625.         result := Check_Res(INT(NEO_Image.res)) ;
  626.         IF result=0 THEN
  627.           BEGIN
  628.             Set_Palette(NEO_image.palette) ;
  629.             FOR x := 1 TO 16000 DO
  630.               screen_buffer[x] := NEO_image.image[x] ;
  631.             init_form(image_area,NEO_image.image,resolution) ;
  632.           END ;
  633.       END ;
  634.     Get_NEO := result ;
  635.   END ;
  636.  
  637. {******************************************************************}
  638. {*  This function reads in a file with the extension of .PI*.     *}
  639. {******************************************************************}
  640.  
  641. FUNCTION Get_PI: Integer ;
  642.  
  643. VAR result, x : Integer ;
  644.  
  645.   BEGIN
  646.     Reset( PI_file, file_name ) ;
  647.     PI_image := PI_file^ ;
  648.     IO_Check(False) ;
  649.     Get( PI_file ) ;
  650.     result := IO_Result ;
  651.     Close( PI_file ) ;
  652.     IO_Check(True) ;
  653.     IF result=0 THEN
  654.       BEGIN
  655.         result := Check_Res(PI_Image.res) ;
  656.         IF result=0 THEN
  657.           BEGIN
  658.             Set_Palette(PI_image.palette) ;
  659.             FOR x := 1 TO 16000 DO
  660.               screen_buffer[x] := PI_image.image[x] ;
  661.             init_form(image_area,PI_image.image,resolution) ;
  662.           END ;
  663.       END ;
  664.     Get_PI := result ;
  665.   END ;
  666.  
  667. {******************************************************************}
  668. {*  This procedure is called at the start of the program.  It     *}
  669. {*  displays the copyright information on Personal Pascal.        *}
  670. {******************************************************************}
  671.  
  672. PROCEDURE copyright_dialog ;
  673.  
  674. VAR copy_dialog : Dialog_Ptr ;
  675.     ACD: Array [0..6] OF Integer ;
  676.     ACD_OK : Integer ;
  677.  
  678.   BEGIN
  679.     copy_dialog := New_Dialog( 10,0,0,36,17) ;
  680.  
  681.     ACD[0] := Add_DItem( copy_dialog,G_String,None,7,2,0,1,0,0) ;
  682.     ACD[1] := Add_DItem( copy_dialog,G_String,None,5,4,0,1,0,0) ;
  683.     ACD[2] := Add_DItem( copy_dialog,G_String,None,2,5,0,1,0,0) ;
  684.     ACD[3] := Add_DItem( copy_dialog,G_String,None,5,6,0,1,0,0) ;
  685.     ACD[4] := Add_DItem( copy_dialog,G_String,None,2,8,0,1,0,0) ;
  686.     ACD[5] := Add_DItem( copy_dialog,G_String,None,2,10,0,1,0,0) ;
  687.     ACD[6] := Add_DItem( copy_dialog,G_String,None,14,11,0,1,0,0) ;
  688.     ACD_OK := Add_DItem( copy_dialog,G_Button,Selectable|Exit_btn,
  689.                             15,13,6,2,0,0) ;
  690.  
  691.     Set_Dtext( copy_dialog,ACD[0],'Picture Puzzle Program',
  692.                System_Font,TE_left) ;
  693.     Set_Dtext( copy_dialog,ACD[1],'Written in Personal Pascal',
  694.                System_Font,TE_Left) ;
  695.     Set_Dtext( copy_dialog,ACD[2],'Copyright (c) 1986, OSS and CCD.',
  696.                System_Font,TE_Left) ;
  697.     Set_Dtext( copy_dialog,ACD[3],'Used by Permission of OSS.',
  698.                System_Font,TE_left) ;
  699.     Set_Dtext( copy_dialog,ACD[4], '    Author: Guy Davis',
  700.                System_Font,TE_Left) ;
  701.     Set_Dtext( copy_dialog,ACD[5], 'User Group: San Diego Atari',
  702.                System_Font,TE_Left) ;
  703.     Set_Dtext( copy_dialog,ACD[6], 'Computer Enthusiasts',
  704.                System_Font,TE_Left) ;
  705.     Set_Dtext( copy_dialog,ACD_OK,' OK ',
  706.                System_Font,TE_Center) ;
  707.  
  708.     center_dialog(copy_dialog) ;
  709.     dummy := do_dialog(copy_dialog, 0) ;
  710.   END ;
  711.  
  712. {******************************************************************}
  713. {*  This procedure checks the extension of the file selected.     *}
  714. {*  This extension can only be .PI1, .PI2, .PI3, .NEO.  If  none  *}
  715. {*  of these extensions are present then an alert box is shown    *}
  716. {*  and the user is then asked to read in another file.           *}
  717. {******************************************************************}
  718.  
  719. FUNCTION valid_extension(file_name: String): Boolean ;
  720.  
  721.   BEGIN
  722.     pi1_spot := Pos( '.PI1', file_name) ;
  723.     pi2_spot := Pos( '.PI2', file_name) ;
  724.     pi3_spot := Pos( '.PI3', file_name) ;
  725.     neo_spot := Pos( '.NEO', file_name) ;
  726.     IF (pi1_spot|pi2_spot|pi3_spot|neo_spot)<>0 THEN
  727.       valid_extension := TRUE
  728.     ELSE
  729.       valid_extension := FALSE ;
  730.   END ;
  731.  
  732. {******************************************************************}
  733. {*  This is the start of the main_loop procedure.                 *}
  734. {******************************************************************}
  735.  
  736.   BEGIN
  737.     erase_screen ;
  738.     copyright_dialog ;
  739.     valid_ext := FALSE ;
  740.     file_to_input := TRUE ;
  741.     file_name := '' ;
  742.  
  743.     WHILE (NOT valid_ext) AND file_to_input DO
  744.       BEGIN
  745.         file_to_input := Get_In_File( default_path, file_name ) ;
  746.         valid_ext := valid_extension(file_name) ;
  747.         IF (NOT valid_ext) AND file_to_input THEN
  748.           BEGIN
  749.             erase_screen ;
  750.             alert_str := Concat('[3][.PI* and .NEO|',
  751.                                     ' files only!][Cancel]') ;
  752.             dummy := Do_Alert(alert_str,1) ;
  753.           END ;
  754.       END ;
  755.  
  756.     WHILE file_to_input DO
  757.       BEGIN
  758.         erase_screen ;
  759.         IF neo_spot<>0 THEN
  760.           result := Get_NEO
  761.         ELSE
  762.           result := Get_PI ;
  763.  
  764.         IF result=0 THEN
  765.           BEGIN
  766.             init_form(backup,screen_buffer,resolution);
  767.             get_squares ;
  768.             IF key<>$011B THEN
  769.               BEGIN
  770.                 shuffle_picture ;
  771.                 exchange_squares ;
  772.                 IF puzzle_solved THEN
  773.                   BEGIN
  774.                     alert_str := Concat('[1][Congratulations!|You solved ',
  775.                                         'The|Picture Puzzle!][ Hurray ]') ;
  776.                     dummy := Do_Alert(alert_str,1) ;
  777.                   END ;
  778.               END ;
  779.             erase_screen ;
  780.           END
  781.         ELSE
  782.           IF result<>-99 THEN
  783.             BEGIN
  784.               alert_str := Concat('[3][Illegal picture|format!  Pick|',
  785.                                   'another file!][Cancel]') ;
  786.               dummy := Do_Alert(alert_str,1) ;
  787.             END ;
  788.  
  789.         valid_ext := FALSE ;
  790.         file_to_input := TRUE ;
  791.  
  792.         WHILE (NOT valid_ext) AND file_to_input DO
  793.           BEGIN
  794.             file_to_input := Get_In_File( default_path, file_name ) ;
  795.             valid_ext := valid_extension(file_name) ;
  796.             IF (NOT valid_ext) AND file_to_input THEN
  797.               BEGIN
  798.                 erase_screen ;
  799.                 alert_str := Concat('[3][.PI* and .NEO|',
  800.                                     ' files only!][Cancel]') ;
  801.                 dummy := Do_Alert(alert_str,1) ;
  802.               END ;
  803.           END ;
  804.       END ;
  805.   END ;
  806.  
  807. {******************************************************************}
  808. {*  This procedure is called at the start of the program to init- *}
  809. {*  ialize program variables.                                     *}
  810. {******************************************************************}
  811.  
  812. PROCEDURE Initialize ;
  813.  
  814. VAR x: integer ;
  815.  
  816. {******************************************************************}
  817. {*  This procedure sets the variables associated with the current *}
  818. {*  resolution.                                                   *}
  819. {******************************************************************}
  820.  
  821. PROCEDURE Set_Res_Vars(resolution: Integer) ;
  822.  
  823. BEGIN
  824.   CASE resolution OF
  825.     Low_Resolution:
  826.       BEGIN
  827.         Wmax := 320 ;
  828.         Hmax := 200 ;
  829.         palette_max := 15 ;
  830.       END ;
  831.     Medium_Resolution:
  832.       BEGIN
  833.         Wmax := 640 ;
  834.         Hmax := 200 ;
  835.         palette_max := 3 ;
  836.       END ;
  837.     High_Resolution:
  838.       BEGIN
  839.         Wmax := 640 ;
  840.         Hmax := 400 ;
  841.         palette_max := 1 ;
  842.       END ;
  843.   END ;
  844. END ;
  845.  
  846. {******************************************************************}
  847. {*  Start of procedure Initialize.                                *}
  848. {******************************************************************}
  849.  
  850.   BEGIN
  851.     init_mouse ;
  852.     resolution := Get_Res ;
  853.     set_res_vars(resolution) ;
  854.     screen[addr1] := 0 ;
  855.     screen[addr2] := 0 ;
  856.     res_string[0] := 'Change to low' ;
  857.     res_string[1] := 'Change to medium' ;
  858.     res_string[2] := 'Change to high' ;
  859.     chosen := 0 ;
  860.     Line_Color(chosen) ;
  861.     default_path := 'A:\*.PI*' ;
  862.     FOR x := 0 TO 15 DO
  863.       save_palette[x] := st_clr(x, -1) ;
  864.   END ;
  865.  
  866. {******************************************************************}
  867. {*  This is the program loop.  Gem is initialized, the program    *}
  868. {*  variables are initialized, the main loop is called and then   *}
  869. {*  the palette is returned to it's original state.               *}
  870. {******************************************************************}
  871.  
  872.   BEGIN
  873.     IF Init_Gem >= 0 THEN
  874.       BEGIN
  875.         Initialize ;
  876.         Main_Loop ;
  877.         Set_Palette(save_palette) ;
  878.         Exit_Gem ;
  879.       END ;
  880.   END.
  881.  
  882.